home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
New Star Software Collection
/
NSS_Collection.iso
/
3-004 ms visual basic pro 30
/
4.imz
/
4.IMA
/
DATAFORM.FR_
/
DATAFORM.bin
Wrap
Text File
|
1993-04-28
|
21KB
|
854 lines
VERSION 2.00
Begin Form fDataForm
BackColor = &H00C0C0C0&
ClientHeight = 2520
ClientLeft = 1815
ClientTop = 3000
ClientWidth = 5700
Height = 2925
Icon = DATAFORM.FRX:0000
Left = 1755
LinkTopic = "Form2"
MDIChild = -1 'True
ScaleHeight = 2520
ScaleWidth = 5700
Tag = "Dynaset"
Top = 2655
Width = 5820
Begin CommonDialog CMD1
Left = 4800
Top = 1800
End
Begin PictureBox StatBox
Align = 2 'Align Bottom
BackColor = &H00C0C0C0&
BorderStyle = 0 'None
Height = 270
Left = 0
ScaleHeight = 282.462
ScaleMode = 0 'User
ScaleWidth = 5710.271
TabIndex = 6
Top = 2250
Width = 5700
Begin Data Data1
Connect = ""
DatabaseName = ""
Exclusive = 0 'False
Height = 270
Left = 0
Options = 0
ReadOnly = 0 'False
RecordSource = ""
Top = 0
Width = 5475
End
End
Begin VScrollBar cScrollBar
Height = 2085
LargeChange = 3000
Left = 7665
SmallChange = 300
TabIndex = 15
Top = 630
Visible = 0 'False
Width = 255
End
Begin PictureBox cFields
BackColor = &H00C0C0C0&
BorderStyle = 0 'None
Height = 1065
Left = 0
ScaleHeight = 1056.48
ScaleMode = 0 'User
ScaleWidth = 7600.262
TabIndex = 10
TabStop = 0 'False
Top = 630
Width = 7605
Begin TextBox cFieldData
BackColor = &H00FFFFFF&
DataSource = "Data1"
ForeColor = &H00000000&
Height = 285
Index = 0
Left = 1665
TabIndex = 13
Top = 0
Visible = 0 'False
Width = 3255
End
Begin CheckBox cFieldCheck
BackColor = &H00C0C0C0&
DataSource = "Data1"
Height = 282
Index = 0
Left = 1680
TabIndex = 12
Top = 735
Visible = 0 'False
Width = 3270
End
Begin PictureBox cFieldPicture
DataSource = "Data1"
Height = 282
Index = 0
Left = 1680
ScaleHeight = 255
ScaleWidth = 3240
TabIndex = 11
Top = 315
Visible = 0 'False
Width = 3270
End
Begin Label cFieldName
BackColor = &H00C0C0C0&
ForeColor = &H00000000&
Height = 255
Index = 0
Left = 105
TabIndex = 14
Top = 0
Visible = 0 'False
Width = 1575
End
End
Begin PictureBox FieldHeader
Align = 1 'Align Top
BackColor = &H00C0C0C0&
BorderStyle = 0 'None
Height = 300
Left = 0
ScaleHeight = 300
ScaleMode = 0 'User
ScaleWidth = 5703.403
TabIndex = 7
Top = 330
Width = 5700
Begin Label FieldValueLabel
BackColor = &H00C0C0C0&
Caption = " Value:"
Height = 252
Left = 1680
TabIndex = 9
Top = 30
Width = 2652
End
Begin Label FieldHdrLabel
BackColor = &H00C0C0C0&
Caption = "Field Name:"
Height = 252
Left = 120
TabIndex = 8
Top = 30
Width = 1212
End
End
Begin PictureBox TopPic
Align = 1 'Align Top
BackColor = &H00C0C0C0&
BorderStyle = 0 'None
Height = 330
Left = 0
ScaleHeight = 330
ScaleWidth = 5700
TabIndex = 0
Top = 0
Width = 5700
Begin CommandButton CancelAddBtn
Caption = "C&ancel"
Height = 330
Left = 0
TabIndex = 17
Top = 0
Visible = 0 'False
Width = 960
End
Begin CommandButton RefreshBtn
Caption = "&Refresh"
Height = 330
Left = 3780
TabIndex = 16
Top = 0
Width = 960
End
Begin CommandButton FindBtn
Caption = "&Find"
Height = 330
Left = 2835
TabIndex = 5
Top = 0
Width = 960
End
Begin CommandButton CloseBtn
Cancel = -1 'True
Caption = "&Close"
Height = 330
Left = 4725
TabIndex = 4
Top = 0
Width = 960
End
Begin CommandButton DeleteBtn
Caption = "&Delete"
Height = 330
Left = 1890
TabIndex = 3
Top = 0
Width = 960
End
Begin CommandButton AddBtn
Caption = "&Add"
Height = 330
Left = 0
TabIndex = 2
Top = 0
Width = 960
End
Begin CommandButton UpdateBtn
Caption = "&Update"
Height = 330
Left = 945
TabIndex = 1
Top = 0
Width = 960
End
End
End
'============================================================================
' This is a fairly generic form that can be used in most cases with any
' table. I am sorry if it is confusing. There is a lot of paths to
' keep track on with adding, editing, browsing, deleting records
' on populated as well as empty tables. I have added flags where I
' felt there was no other way to achieve the correct functionality.
' I am sure that you can improve this form greatly with a little
' time and understanding of your spcific needs. There is also some
' recursion that could be trapped but hopefully, the form will be
' a good starting point for any data control app.
'============================================================================
Dim FldArr() As control
Dim FDS As dynaset
Dim FBM As String 'form global bookmark
Dim numFlds As Integer
Dim CurrField As Integer
Dim CurrRec As Long
Dim TotRec As Long
Dim JustUsedFind As Integer 'flag for find function
Dim fResizing As Integer 'flag to avoid resize recursion
Dim CancelFlag As Integer 'flag to cancel an addnew
Dim FldTop As Integer
Const EM_NOTHING = 0
Const EM_EDIT = 1
Const EM_ADDNEW = 2
Const FT_TRUEFALSE = 1
Const FT_BYTE = 2
Const FT_INTEGER = 3
Const FT_LONG = 4
Const FT_CURRENCY = 5
Const FT_SINGLE = 6
Const FT_DOUBLE = 7
Const FT_DATETIME = 8
Const FT_STRING = 10
Const FT_BINARY = 11
Const FT_MEMO = 12
Const YES = 6
Const MSGBOX_TYPE = 4 + 48
Sub AddBtn_Click ()
On Error GoTo AddErr
Data1.Recordset.AddNew
Data1.Caption = "New Record"
CancelAddBtn.Visible = True
AddBtn.Visible = False
If Data1.Recordset.RecordCount <> 0 Then
FBM = Data1.Recordset.Bookmark
FldArr(0).SetFocus
End If
GoTo AddEnd
AddErr:
MsgBox Error$
Resume AddEnd
AddEnd:
End Sub
Sub CancelAddBtn_Click ()
On Error Resume Next
CancelFlag = True
If FBM <> "" Then
Data1.Recordset.Bookmark = FBM
End If
If FDS.RecordCount > 0 Then
SetRecNum
End If
End Sub
Sub cFieldData_KeyPress (Index As Integer, KeyAscii As Integer)
'go to next field on an enter keypress
If KeyAscii = 13 Then
KeyAscii = 0
SendKeys "{Tab}"
End If
End Sub
Sub cFieldPicture_Click (Index As Integer)
'this toggles the size of a picture control
'so it mat be viewed or compressed
If cFieldPicture(Index).Height <= 280 Then
cFieldPicture(Index).AutoSize = True
Else
cFieldPicture(Index).AutoSize = False
cFieldPicture(Index).Height = 280
End If
End Sub
Sub cFieldPicture_DblClick (Index As Integer)
On Error GoTo PicErr
CMD1.Filter = "Bitmaps (*.bmp)|*.bmp|Icons (*.ico)|*.ico|Metafiles (*.wmf)|*.wmf|All Files (*.*)|*.*"
CMD1.DialogTitle = "Select a Picture File to Load"
CMD1.FilterIndex = 1
CMD1.Action = 1
If CMD1.Filename <> "" Then
cFieldPicture(Index).Picture = LoadPicture(CMD1.Filename)
End If
GoTo PicEnd
PicErr:
MsgBox Error$
Resume PicEnd
PicEnd:
End Sub
Sub CloseBtn_Click ()
On Error Resume Next
Unload Me
End Sub
Sub cScrollBar_Change ()
Dim t As Integer
t = cScrollBar
If (t - FldTop) Mod 300 = 0 Then
cFields.Top = t
Else
cFields.Top = ((t - FldTop) \ 300) * 300 + FldTop
End If
End Sub
Sub Data1_Error (DataErr As Integer, Response As Integer)
MsgBox "Data error event hit err:" + Error$(DataErr)
End Sub
Sub Data1_RePosition ()
Dim bm As String
Dim ds As dynaset
If Data1.Recordset.RecordCount = 0 And Data1.EditMode <> 2 Then
Call AddBtn_Click
Exit Sub
End If
If JustUsedFind = True Then
Set ds = Data1.Recordset.Clone()
bm = Data1.Recordset.Bookmark
ds.MoveFirst
CurrRec = 1
While ds.Bookmark <> bm
CurrRec = CurrRec + 1
ds.MoveNext
Wend
JustUsedFind = False
End If
SetRecNum
End Sub
Sub Data1_Validate (Action As Integer, Save As Integer)
On Error GoTo ValErr
If CancelFlag Then
Save = False
CancelFlag = False
Exit Sub
End If
'first check for a move from an addnew or edit record
If Action < 5 Then
If Save = True Then 'data changed
If Data1.EditMode = EM_ADDNEW Then
If MsgBox("Save New Record?", MSGBOX_TYPE) = YES Then
TotRec = TotRec + 1
Else
Save = False
End If
Else
If MsgBox("Commit Changes?", MSGBOX_TYPE) <> YES Then
Save = False 'loose changes
End If
End If
End If
SetRecNum
End If
Select Case Action
Case 1 'First
CurrRec = 1
Case 2 'Previous
If CurrRec = 1 Then Beep
If CurrRec <> 1 Then CurrRec = CurrRec - 1
Case 3 'Next
If CurrRec = TotRec Then Beep
If CurrRec <> TotRec Then CurrRec = CurrRec + 1
Case 4 'Last
CurrRec = TotRec
Case 5 'AddNew
'do nothing
Case 6 'Update
If Save = True Then
If Data1.EditMode = EM_ADDNEW Then
If MsgBox("Save New Record?", MSGBOX_TYPE) = YES Then
TotRec = TotRec + 1
Else
Save = False
End If
Else
If MsgBox("Commit Changes?", MSGBOX_TYPE) <> YES Then
Save = False
End If
End If
End If
Case 7 'Delete
TotRec = TotRec - 1
SetRecNum
Case 8
'set the flag for use in the reposition event
JustUsedFind = True
Case 9 'BookMark
'do nothing"
Case 10 'Close
If Save = True Then
If MsgBox("Commit Changes before Closing?", MSGBOX_TYPE) <> YES Then
Save = False
End If
End If
End Select
GoTo ValEnd
ValErr:
ShowError
Resume ValEnd
ValEnd:
End Sub
Sub DeleteBtn_Click ()
On Error GoTo DelErr
If MsgBox("Delete Current Record?", MSGBOX_TYPE) = YES Then
Data1.Recordset.Delete
Data1.Recordset.MoveNext
FldArr(0).SetFocus
End If
GoTo DelEnd
DelErr:
MsgBox Error$
Resume DelEnd
DelEnd:
End Sub
Sub FindBtn_Click ()
On Error GoTo FindErr
Dim bm As String, findstr As String
findstr = InputBox("Enter Search Expression:")
If findstr = "" Then Exit Sub
If Data1.Recordset.RecordCount > 0 Then
bm = Data1.Recordset.Bookmark
End If
Data1.Recordset.FindFirst findstr
'return to old record if no match was found
If Data1.Recordset.NoMatch And bm <> "" Then
Data1.Recordset.Bookmark = bm
End If
GoTo FindEnd
FindErr:
MsgBox Error$
Resume FindEnd
FindEnd:
FldArr(0).SetFocus
End Sub
Sub Form_Load ()
Dim ds2 As dynaset
Dim Start, Finish
On Error GoTo LoadErr
'-------------------------------------------------------
'this is where the data control properties get
'set from whatever source they are coming from
'in this case, it is form1 controls
'-------------------------------------------------------
If gstDataType <> "ODBC" Then
Data1.DatabaseName = gCurrentDB.Name
End If
Data1.Connect = gCurrentDB.Connect
'determine if a table name or sql statement is used
If gfFromSQL = True Then
If gstDynaString = "" Then
Data1.RecordSource = fSQL.cSQLStatement
Else
Data1.RecordSource = gstDynaString
End If
Caption = "Dynaset: SQL Statement"
Else
Data1.RecordSource = fTables.cTableList
Caption = "Dynaset: " + UCase(fTables.cTableList)
End If
'-------------------------------------------------------
If gfFromSQL = True And fSQL.cPassThru = 1 Then
Data1.Options = VBDA_SQLPASSTHROUGH
End If
Start = Timer
Data1.Refresh
CurrRec = 1
Set ds2 = Data1.Recordset.Clone()
If ds2.BOF = False Then
ds2.MoveLast
TotRec = ds2.RecordCount
Else
TotRec = 0
End If
ds2.Close
Width = 5805
LoadFields
Me.Show
FldArr(0).SetFocus
SetRecNum
Finish = Timer
If VDMDI.PrefShowPerf.Checked Then
MsgBox CStr(TotRec) + " rows found in " + CStr(Finish - Start) + " seconds!", 48
End If
GoTo LoadEnd
LoadErr:
ShowError
Unload Me
Resume LoadEnd
LoadEnd:
End Sub
Sub Form_Resize ()
On Error Resume Next
If fResizing = True Then Exit Sub
Dim h As Integer, i As Integer
Dim totw As Integer
fResizing = True
If WindowState <> 1 And cFieldName(0).Visible = True Then 'not minimized
'make sure the form is lined up on a field
h = Height
If (h - 1320) Mod 300 <> 0 Then
Height = ((h - 1320) \ 300) * 300 + 1320
End If
'resize the status bar
StatBox.Top = Height - 650
'resize the scrollbar
cScrollBar.Height = StatBox.Top - (FieldHeader.Top - FieldHeader.Height) - 600
cScrollBar.Left = Width - 360
If FDS.Fields.Count > 10 Then
cFields.Width = Width - 260
totw = cScrollBar.Left - 20
Else
cFields.Width = Width - 20
totw = Width - 50
End If
FieldHeader.Width = Width - 20
'widen the fields if possible
For i = 0 To FDS.Fields.Count - 1
cFieldName(i).Width = .3 * totw
FldArr(i).Left = cFieldName(i).Width + 20
If Data1.Recordset.Fields(i).Type > 9 Then
FldArr(i).Width = .7 * totw - 270
End If
Next
FieldValueLabel.Left = FldArr(0).Left
End If
Data1.Width = StatBox.Width
fResizing = False
End Sub
Function GetFieldWidth (t As Integer)
'determines the form control width
'based on the field type
Select Case t
Case FT_TRUEFALSE
GetFieldWidth = 850
Case FT_BYTE
GetFieldWidth = 650
Case FT_INTEGER
GetFieldWidth = 900
Case FT_LONG
GetFieldWidth = 1100
Case FT_CURRENCY
GetFieldWidth = 1800
Case FT_SINGLE
GetFieldWidth = 1800
Case FT_DOUBLE
GetFieldWidth = 2200
Case FT_DATETIME
GetFieldWidth = 2000
Case FT_STRING
GetFieldWidth = 3250
Case FT_MEMO
GetFieldWidth = 3250
Case Else
GetFieldWidth = 3250
End Select
End Function
Sub LoadFields ()
Dim t As dynaset
Dim ds As String 'temp dynaset name string
Dim ft As Integer
Dim i As Integer
On Error GoTo LoadFieldsErr
Set FDS = Data1.Recordset
Set t = FDS
'load the controls on the dynaset form
numFlds = t.Fields.Count
ReDim FldArr(numFlds) As control
cFieldName(0).Visible = True
ft = t.Fields(0).Type
If ft = FT_TRUEFALSE Then
Set FldArr(0) = cFieldCheck(0)
ElseIf ft = FT_BINARY Then
Set FldArr(0) = cFieldPicture(0)
Else
Set FldArr(0) = cFieldData(0)
End If
FldArr(0).Visible = True
FldArr(0).Top = 0
FldArr(0).Width = GetFieldWidth(ft)
FldArr(0).TabIndex = 0
On Error Resume Next
For i = 1 To t.Fields.Count - 1
cFields.Height = cFields.Height + 300
Load cFieldName(i)
cFieldName(i).Top = cFieldName(i - 1).Top + 300
cFieldName(i).Visible = True
ft = t.Fields(i).Type
If ft = FT_TRUEFALSE Then
Load cFieldCheck(i)
Set FldArr(i) = cFieldCheck(i)
ElseIf ft = FT_BINARY Then
Load cFieldPicture(i)
Set FldArr(i) = cFieldPicture(i)
Else
Load cFieldData(i)
Set FldArr(i) = cFieldData(i)
End If
FldArr(i).Top = FldArr(i - 1).Top + 300
FldArr(i).Visible = True
FldArr(i).Width = GetFieldWidth(ft)
FldArr(i).TabIndex = i
Next
On Error GoTo LoadFieldsErr
'resize main window
cFields.Top = FieldHeader.Top + FieldHeader.Height
FldTop = cFields.Top
cScrollBar = FldTop
If i <= 10 Then
Height = i * 300 + 1500
cScrollBar.Visible = False
Else
Height = 4500
Width = Width + 260
cScrollBar.Visible = True
cScrollBar.Min = FldTop
cScrollBar.Max = FldTop - (i * 300) + 3000
End If
'display the field names
For i = 0 To t.Fields.Count - 1
cFieldName(i) = UCase(t.Fields(i).Name) + ":"
Next
'bind the controls
On Error Resume Next 'bind even if table is empty
For i = 0 To t.Fields.Count - 1
FldArr(i).DataField = t.Fields(i).Name
Next
GoTo LoadFieldsEnd
LoadFieldsErr:
MsgBox Error$
Resume LoadFieldsEnd
LoadFieldsEnd:
End Sub
Sub MoveBtn_Click (Index As Integer)
On Error GoTo moveerr
Dim bm As String
If Not Data1.Recordset.BOF And Not Data1.Recordset.EOF Then
bm = Data1.Recordset.Bookmark
End If
Select Case Index
Case 0
If findval <> "" Then
Data1.Recordset.FindFirst findval
Else
Data1.Recordset.MoveFirst
End If
Case 1
If findval <> "" Then
Data1.Recordset.FindPrevious findval
Else
Data1.Recordset.MovePrevious
End If
Case 2
If findval <> "" Then
Data1.Recordset.FindNext findval
Else
Data1.Recordset.MoveNext
End If
Case 3
If findval <> "" Then
Data1.Recordset.FindLast findval
Else
Data1.Recordset.MoveLast
End If
End Select
'return to old record if no match was found
If Data1.Recordset.NoMatch And bm <> "" Then
Data1.Recordset.Bookmark = bm
End If
GoTo moveend
moveerr:
MsgBox Error$
Resume moveend
moveend:
FldArr(0).SetFocus
End Sub
Sub RefreshBtn_Click ()
On Error GoTo RefErr
Data1.Refresh
GoTo RefEnd
RefErr:
ShowError
Resume RefEnd
RefEnd:
End Sub
Sub SetRecNum ()
If Data1.EditMode <> 2 Then
If Data1.Recordset.BOF = True Then
Data1.Caption = "Record BOF of " & TotRec
ElseIf Data1.Recordset.EOF = True Then
Data1.Caption = "Record EOF of " & TotRec
Else
Data1.Caption = "Record " & CurrRec & " of " & TotRec
End If
End If
'reset buttons if needed
If Data1.EditMode <> 2 Then
CancelAddBtn.Visible = False
AddBtn.Visible = True
End If
End Sub
Sub UpdateBtn_Click ()
On Error GoTo UpdErr
Dim addflag As Integer
addflag = Data1.EditMode
Data1.Recordset.Update
If addflag = 2 Then
FDS.MoveLast
End If
GoTo UpdEnd
UpdErr:
ShowError
Resume UpdEnd
UpdEnd:
End Sub